home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 090 / pctjnv85.arc / SURFACE.PAS < prev   
Pascal/Delphi Source File  |  1985-08-30  |  6KB  |  228 lines
  1. Program SURFACE;
  2.  
  3.  
  4. {- - - - - DEFINE FUNCTION TO BE GRAPHED - - - - - - - - - - - }
  5.  
  6. Function f(x,y:real):real;       { Change this entry in order  }
  7. begin                            {  to graph another function. }
  8.    f := exp(-(x*y+y*y)/90)*cos((x*x+y*y)/40);
  9. end;
  10.  
  11. {- - - - - DECLARATIONS- - - - - - - - - - - - - - - - - - - - }
  12.  
  13. const
  14.    xdiv = 40;           {* * * These two constants control the }
  15.    ydiv = 60;           { number of subdivisions of each axis  }
  16.  
  17.    xeye = 100;          {* * * These three constants determine }
  18.    yeye = 10;           { the eye position from which the      }
  19.    zeye = 8;            { surface is viewed. }
  20.                   { NOTE : xeye and yeye should be nonnegative.}
  21.  
  22. var
  23.    i, j               :    integer;
  24.    xmax, xmin, ymax   :    real;
  25.    ymin, zmax, zmin   :    real;
  26.    xdif, ydif, zdif   :    real;
  27.    p, q               :    array[0..xdiv,0..ydiv] of integer;
  28.  
  29.    y, z               :    array[0..xdiv,0..ydiv] of real;
  30.  
  31.  
  32. {- - - - - INPUT EXTREME VALUES FOR X, Y - - - - - - - - - - - }
  33.  
  34. Procedure INPUT_DOMAIN;
  35. begin
  36.    write('Enter smallest value of x  ');
  37.    readln(xmin);
  38.    write('Enter  largest value of x  ');
  39.    readln(xmax); xdif := xmax - xmin;
  40.    write('Enter smallest value of y  ');
  41.    readln(ymin);
  42.    write('Enter  largest value of y  ');
  43.    readln(ymax); ydif := ymax - ymin;
  44. end;
  45.  
  46. {- - - - - EVALUATE FUNCTION AT GRID POINTS; - - - - - - - - - }
  47.  
  48. {- - - - - PROJECT TO VIEW PLANE - - - - - - - - - - - - - - - }
  49.  
  50.  
  51. Procedure EVALUATE_AND_PROJECT;
  52. var
  53.    xtemp,xtemp1,xtemp2,ytemp,ytemp1,ztemp,xavg,yavg  :  real;
  54.  
  55. begin
  56.   xavg := (xmax + xmin)/2; yavg := (ymax + ymin)/2;
  57.   for i := 0 to xdiv do
  58.     for j := 0 to ydiv do 
  59.       begin 
  60.         xtemp := xmin + i*xdif/xdiv; 
  61.         ytemp := ymin + j*ydif/ydiv; 
  62.         ztemp := f(xtemp,ytemp); 
  63.         xtemp1 := xeye - xtemp; 
  64.         ytemp1 := yeye - ytemp; 
  65.         y[i,j] := (xeye - xavg)*(xeye*ytemp - yeye*xtemp)/
  66.  
  67.                   ((xeye - xavg)*xtemp1 + (yeye - yavg)*ytemp1);
  68.  
  69.         if y[i,j] <> yeye then 
  70.           z[i,j] := zeye + (zeye - ztemp)*(y[i,j] - yeye)/ytemp1
  71.  
  72.          else 
  73.            begin 
  74.              xtemp2 := yeye*(yavg-yeye)/(xeye-xavg); 
  75.              z[i,j] := zeye +  
  76.                (zeye - ztemp)*(xtemp2 - xeye)/xtemp1 
  77.            end; 
  78.       end; 
  79. end; 
  80.  
  81. {- - - - - DETERMINE PROJECTED EXTREMA - - - - - - - - - - - - }
  82.  
  83. Procedure FIND_EXTREMA; 
  84. var 
  85.    ytemp,ztemp  :  real; 
  86. begin 
  87.    ymax := y[0,0]; ymin := ymax; 
  88.    zmax := z[0,0]; zmin := zmax; 
  89.    for i := 0 to xdiv do 
  90.       for j := 0 to ydiv do 
  91.       begin 
  92.          ytemp := y[i,j]; ztemp := z[i,j]; 
  93.          if ytemp > ymax then ymax := ytemp; 
  94.          if ytemp < ymin then ymin := ytemp; 
  95.          if ztemp > zmax then zmax := ztemp; 
  96.          if ztemp < zmin then zmin := ztemp; 
  97.       end; 
  98. end; 
  99.  
  100. {- - - - - SCALE TO SCREEN - - - - - - - - - - - - - - - - - - }
  101.  
  102. Procedure SCALE_TO_SCREEN; 
  103. var 
  104.    dy,dz  :  real; 
  105. begin 
  106.    dy := (ymax - ymin)/639; dz := (zmax - zmin)/199; 
  107.    for i := 0 to xdiv do 
  108.       for j := 0 to ydiv do 
  109.       begin 
  110.          p[i,j] := round((y[i,j] - ymin)/dy); 
  111.          q[i,j] := 199 - round((z[i,j] - zmin)/dz); 
  112.       end; 
  113. end; 
  114.  
  115. {- - - - - EXCHANGE COORDINATES OF TWO POINTS- - - - - - - - - }
  116.  
  117. Procedure SWAP(var x1,y1,x2,y2:integer); 
  118. var 
  119.    temp : integer; 
  120. begin 
  121.    temp := x1; x1 := x2; x2 := temp; 
  122.    temp := y1; y1 := y2; y2 := temp; 
  123. end; 
  124.  
  125. {- - - - - DRAWS BLANK HORIRONTAL LINE - - - - - - - - - - - - }
  126.  
  127. Procedure LINE(x0,x1,y:integer); 
  128. begin 
  129.    inline($8B/$BE/x1/               {MOV DI,x1} 
  130.           $8B/$8E/x0/               {MOV CX,x0} 
  131.           $39/$CF/                  {CMP DI,CX} 
  132.           $7D/$02/                  {JGE 2 bytes} 
  133.           $87/$F9/                  {XCHG CX,DI} 
  134.           $8B/$96/y/                {MOV DX,y } 
  135.           $BB/$00/$0C/              {MOV BX,0C00} 
  136.           $89/$D8/                  {L1: MOV AX,BX} 
  137.           $CD/$10/                  {INT 10H} 
  138.           $41/                      {INC CX} 
  139.           $3B/$F9/                  {CMP DI,CX} 
  140.           $7D/$F7);                 {JG L1} 
  141. end; 
  142.  
  143. {- - - - - BLANKS TRIANGLE - - - - - - - - - - - - - - - - - - }
  144.  
  145.  
  146. Procedure TRIBLANK(x0,y0,x1,y1,x2,y2:integer); 
  147. var 
  148.    x3,x4,dx1,dx2,dy1,dy2         :    integer; 
  149.    inc1,inc2,nx1,nx2             :    integer; 
  150.  
  151. Procedure BLANK(y:integer); 
  152. begin 
  153.    while y0 < y do 
  154.    begin 
  155.       nx1 := nx1 + dx1; 
  156.       if nx1 > dy1 then 
  157.       repeat 
  158.          x3 := x3 + inc1; 
  159.          nx1 := nx1 - dy1; 
  160.       until nx1 <= dy1; 
  161.       nx2 := nx2 + dx2; 
  162.       if nx2 > dy2 then 
  163.       repeat 
  164.          x4 := x4 + inc2; 
  165.          nx2 := nx2 - dy2; 
  166.       until nx2 <= dy2; 
  167.       y0 := y0 + 1; 
  168.       line(x3,x4,y0); 
  169.    end; 
  170. end; 
  171.  
  172. begin 
  173.    if y1 < y0 then swap(x0,y0,x1,y1); 
  174.    if y2 < y0 then swap(x0,y0,x2,y2); 
  175.    if y2 < y1 then swap(x1,y1,x2,y2); 
  176.    dy1 := y1 - y0; dy2 := y2 - y0; 
  177.    if x1 < x0 then inc1 := -1 else inc1 := 1; 
  178.    if x2 < x0 then inc2 := -1 else inc2 := 1; 
  179.    dx1 := abs(x1-x0); dx2 := abs(x2-x0); 
  180.    x3 := x0; x4 := x0; 
  181.    nx1 := dy1 div 2; nx2 := dy2 div 2; 
  182.    blank(y1); 
  183.    if x2 < x1 then inc1 := -1 else inc1 := 1; 
  184.    x3 := x1; dy1 := y2 - y1; 
  185.    dx1 := abs(x1 - x2); nx1 := dy1 div 2; 
  186.    blank(y2); 
  187. end; 
  188.  
  189. {- - - - - DRAWS BOX WITH BLANK INTERIOR - - - - - - - - - - - }
  190.  
  191. Procedure DRAWBOX(x1,y1,x2,y2,x3,y3,x4,y4 : integer); 
  192. begin 
  193.    triblank(x1,y1,x2,y2,x3,y3); 
  194.    triblank(x2,y2,x3,y3,x4,y4); 
  195.    draw(x1,y1,x2,y2,1); draw(x1,y1,x3,y3,1); 
  196.    draw(x2,y2,x4,y4,1); draw(x3,y3,x4,y4,1); 
  197. end; 
  198.  
  199. {- - - - - DRAWS SURFACE - - - - - - - - - - - - - - - - - - - }
  200.  
  201. Procedure GRAPH; 
  202. var 
  203.    x1,x2,x3,x4,y1,y2,y3,y4   :  integer; 
  204. begin 
  205.    HiRes; HiResColor(10); 
  206.    for i := 0 to xdiv-1 do 
  207.       for j := 0 to ydiv-1 do 
  208.       begin 
  209.          x1 := p[i,j];   x2 := p[i+1,j];  
  210.      x3 := p[i,j+1]; x4 := p[i+1,j+1]; 
  211.          y1 := q[i,j];   y2 := q[i+1,j];  
  212.      y3 := q[i,j+1]; y4 := q[i+1,j+1]; 
  213.          drawbox(x1,y1,x2,y2,x3,y3,x4,y4); 
  214.       end; 
  215. end; 
  216.  
  217. {- - - - - MAIN PROGRAM BEGINS - - - - - - - - - - - - - - - - }
  218.  
  219.  
  220. begin 
  221.    input_domain; 
  222.    evaluate_and_project; 
  223.    find_extrema; 
  224.    scale_to_screen; 
  225.    graph; 
  226.    repeat until keypressed; 
  227.    TextMode(3); 
  228. end.